Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE08/DATADICT/OLDUTILS.PAS

Pascal/Delphi Source File | 1995-10-09 | 11.1 KB | 301 lines

unit Oldutils;
interface
const
  DevScreenWidth: LongInt = 1024; {design modes}
  DevScreenHeight: LongInt = 768;
  DevPixelsPerInch : Longint = 120;
type                            { from DOS.PAS, RTL 5.5, BP7}
  PathStr = string[79];         { File pathname string }
  DirStr  = string[67];         { Drive and directory string }
  NameStr = string[8];          { File name string }
  ExtStr  = string[4];          { File extension string }
var
  pathholder : pathstr;
  Dirholder  : dirstr;
  nameholder : namestr;
  extholder  : extstr;



function StringAsPChar(var S: OpenString): PChar;
function AddBackSlash(const S: String): String;
function StripBackSlash(const S: String): String;
function WinExecAndWait(Path: String; Visibility: word): word;
function GetEnvVar(EnvVar: String): String;
procedure CopyFile(Source, Dest: String);
function appName : string;                         {my addition}
function noSlashstring(const s: string): string;
procedure FSplit(Path: PathStr; var Dir: DirStr;   {from DOS.PAS}
  var Name: NameStr; var Ext: ExtStr);
function ThisFileDateTime(fname : string): tdatetime;

Procedure ScaleForm(sender: Tobject);   {from TI 2861, scaling forms}
implementation

uses SysUtils, LZExpand, WinTypes, WinProcs, Forms, Controls,
     stdctrls, buttons, graphics, dbctrls;


function StringAsPChar(var S: OpenString): PChar;
{ This function null-terminates a string so that it can be passed to functions }
{ that require PChar types. If string is longer than 254 chars, then it will   }
{ be truncated to 254. }
begin
  if Length(S) = High(S) then Dec(S[0]); { Truncate S if it's too long }
  S[Ord(Length(S)) + 1] := #0;           { Place null at end of string }
  Result := @S[1];                       { Return "PChar'd" string }
end;


function AddBackSlash(const S: String): String;
{ Adds a backslash to string S.  If S is already 255 chars or already has }
{ trailing backslash, then function returns S. }
begin
  if (Length(S) < 255) and (S[Length(S)] <> '\') then
    Result := S + '\'
  else
    Result := S;
end;

function StripBackSlash(const S: String): String;
{ Removes trailing backslash from S, if one exists }
begin
  Result := S;
  if Result[Length(Result)] = '\' then
    Dec(Result[0]);
end;

function WinExecAndWait(Path: String; Visibility: word): word;
var
  InstanceID : THandle;
begin
  { Convert String to PChar, and try to run the application }
  InstanceID := WinExec(StringAsPChar(Path),Visibility);
  if InstanceID < 32 then { a value less than 32 indicates an Exec error }
     WinExecAndWait := InstanceID
  else begin
    repeat
      Application.ProcessMessages;
    until Application.Terminated or (GetModuleUsage(InstanceID) = 0);
    WinExecAndWait := 32;
  end;
end;

function GetEnvVar(EnvVar: String): String;
{ Returns the value of the DOS environment variable passed in EnvVar.       }
{ Note: EnvVar must be 253 chars or less, or it will be truncated to 253.   }
{ Note2: Under Win32, the GetEnvironmentVariable() function should be used. }
var
  P: PChar;
begin
  Result := '';                                { return empty string on fail }
  P := GetDOSEnvironment;                      { retrieve pointer to env vars }
  if EnvVar[0] > #253 then EnvVar[0] := #253;  { truncate if too long }
  EnvVar := EnvVar + '=';                      { append "=" sign to string }
  StringAsPChar(EnvVar);                       { add null-terminator }
  while P^ <> #0 do
    { does first environment variable match EnvVar? }
    if StrLIComp(P, @EnvVar[1], Length(EnvVar)) <> 0 then
      inc(P, StrLen(P) + 1)                    { if not, then go to next }
    else begin
      inc(P, Length(EnvVar));                  { if so, the get value }
      Result := StrPas(P);                     { return a string }
      Break;                                   { get out of loop }
    end;
end;

procedure CopyFile(Source, Dest: String);
var
  SourceHand, DestHand: Integer;
  OpenBuf: TOFStruct;
begin
  { Open source file, and pass our psuedo-PChar as the filename }
  SourceHand := LZOpenFile(StringAsPChar(Source), OpenBuf, of_Share_Deny_Write or of_Read);
  { raise an exception on error }
  if SourceHand = -1 then
    raise EInOutError.Create('Error opening source file "' + Source + '"');
  try
    { Open destination file, and pass our psuedo-PChar as the filename }
    DestHand := LZOpenFile(StringAsPChar(Dest), OpenBuf, of_Share_Exclusive or of_Write
                           or of_Create);
    { Check for error and raise exception }
    if DestHand = -1 then
      raise EInOutError.CreateFmt('Error opening destination file "%s"',[Dest]);
    try
      { copy source to dest, raise exception on error }
      if LZCopy(SourceHand, DestHand) < 0 then
        raise EInOutError.CreateFmt('Error copying file "%s"', [Source]);
    finally
      { whether or not an exception occurs, we need to close the files }
      LZClose(DestHand);
    end;
  finally
    LZClose(SourceHand);
  end;
end;

function appName : string;
begin
  result := copy(application.exename, 1, pos('.',application.exename)-1);
end;

function noSlashstring(const s: string): string;
{assumes s is a fully qualified filename}
{takes out '\' and '.'}
{alias name max is dbmaxnamelen,31}
var extra : integer;
begin
  result := s[1]+copy(s,3,255);   {extract the :}
  while pos('\',result) <> 0 do
    result := copy(result, 1, pos('\',result)-1)+
              copy(result, pos('\', result)+1, 255);
  result := copy(result, 1, pos('.', result)-1) +
            copy(result, pos('.', result)+1, 255);
  extra := length(result) - 31;
  if extra > 0
    then result := result[1] + copy(result, extra+1, 255);
end;



{$L SPLT.OBJ}           { File name split routine }
 {brought in without changes from my old BP7 files}
 {I suppose Delphi must have something similar, but so far it's
  been hiding from me...}
procedure FSplit(Path: PathStr; var Dir: DirStr;
  var Name: NameStr; var Ext: ExtStr); external {SPLT};

function ThisFileDateTime(fname : string): tdatetime;
  var searchRec : TsearchRec;
begin
   FindFirst(fname, faAnyfile, SearchRec);
   result := fileDateToDateTime(SearchRec.time);
end;

function CurrentTextWidth(cur_canvas : tcanvas; const whatstr : string): integer;
 var TextMetric : tTextMetric;
begin
  getTextMetrics(cur_canvas.handle, textMetric);
  result := (textMetric.tmAveCharWidth * length(whatstr))+2;
end;

function CurrentTextHeight(cur_canvas : tcanvas): integer;
 var TextMetric : tTextMetric;
begin
  getTextMetrics(cur_canvas.handle, textMetric);
  result := textMetric.tmHeight + textMetric.tmExternalLeading;
end;


Procedure ScaleForm(sender: Tobject);
  {this is stuff from one of Borland's TI docs.  Doesn't do a very good job...}
var
  i: integer;  {used by font scaler}
  cur_canvas : tcanvas;
  cur_items, cur_width, org_width : integer;
begin
 with sender as tform do begin
   scaled := true;
{   AutoScroll := false;  {true = 'don't change the form's frame size at runtime' }
   position := poScreenCenter;
   if true {screen.width = DevScreenWidth}
     then begin
       if (width > (screen.width-3)) or (height > (screen.height -3))
           then windowState := wsMaximized;
{           else scaleby(DevPixelsPerInch, Screen.PixelsPerInch);}
       for i := componentCount - 1 downto 0 do
         begin
           if components[i] is Tlabel
             then  with components[i] as Tlabel do
               begin
                 font.height := height - 7;
                 {
                 cur_canvas := canvas;
                 if font.height > height
                   then font.height := font.height - (height - font.height-1);
                 width := currentTextWidth(cur_canvas, caption);
                 Height := currentTextHeight(cur_canvas)+2;
                 {adjust width pitch}
                 {textMetrics }
                 end;
           if components[i] is TEdit
             then  with components[i] as TEdit do
               begin
                 font.height := height - 7;
                 {cur_canvas := canvas;}
                 {height := canvas.textHeight('M')+3;}
                { width := currentTextWidth(cur_canvas, caption);}
                 {Height := currentTextHeight(cur_canvas)+2;}
                 {if abs(font.height) > height
                   then font.height := abs(font.height) - (height - abs(font.height)-2);}
                 end;
           if components[i] is TListBox
             then  with components[i] as TListBox do
               begin
                 if font.height > Itemheight
                   then font.height := font.height - (Itemheight - font.height-1);
                 end;
           if components[i] is TdbRadioGroup
             then  with components[i] as TdbRadioGroup do
               begin
                 cur_canvas := canvas;
                 org_width := 0;
                 for cur_items := 0 to items.count -1 do
                   begin
                     cur_width := currentTextWidth(cur_canvas, items[cur_items]+values[cur_items]);
                     cur_width := cur_width + 32;  {width of checkbox?}
                     if cur_width > org_width
                       then org_width := cur_width;
                     end;
                 width := org_width;
                 Height := (currentTextHeight(cur_canvas)+1)*items.count-1;
                 end;
           if components[i] is Tbutton
             then  with components[i] as Tbutton do
                begin
                  {examin width of actual text to width of box
                   and ajdust; same for height}
                end;
           end;
       end;
   end;
end;

end.
{ from help on components    for I := 0 to ComponentCount -1 do
     if Components[I] is TButton then
       TButton(Components[I]).Font.Name := 'Courier';
  Edit1.Text := IntToStr(ComponentCount) + ' components';
end;}

{  from typinfo.int...
function GetTypeData(TypeInfo: PTypeInfo): PTypeData;

function GetEnumName(TypeInfo: PTypeInfo; Value: Integer): PString;
function GetEnumValue(TypeInfo: PTypeInfo; const EnumName: string): Integer;

function GetPropInfo(TypeInfo: PTypeInfo; const PropName: string): PPropInfo;
procedure GetPropInfos(TypeInfo: PTypeInfo; PropList: PPropList);
function GetPropList(TypeInfo: PTypeInfo; TypeKinds: TTypeKinds;
  PropList: PPropList): Integer;

function IsStoredProp(Instance: TObject; PropInfo: PPropInfo): Boolean;

function GetOrdProp(Instance: TObject; PropInfo: PPropInfo): Longint;
procedure SetOrdProp(Instance: TObject; PropInfo: PPropInfo;
  Value: Longint);

function GetStrProp(Instance: TObject; PropInfo: PPropInfo): string;
procedure SetStrProp(Instance: TObject; PropInfo: PPropInfo;
  const Value: string);

function GetFloatProp(Instance: TObject; PropInfo: PPropInfo): Extended;
procedure SetFloatProp(Instance: TObject; PropInfo: PPropInfo;
  Value: Extended);

function GetMethodProp(Instance: TObject; PropInfo: PPropInfo): TMethod;
procedure SetMethodProp(Instance: TObject; PropInfo: PPropInfo;
  const Value: TMethod);

}